home *** CD-ROM | disk | FTP | other *** search
/ Atari Mega Archive 1 / Atari Mega Archive - Volume 1.iso / language / pcl_src.zoo / vector.lsp < prev    next >
Lisp/Scheme  |  1992-07-11  |  20KB  |  455 lines
  1. ;;;-*-Mode:LISP; Package:(PCL LISP 1000); Base:10; Syntax:Common-lisp -*-
  2. ;;;
  3. ;;; *************************************************************************
  4. ;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
  5. ;;; All rights reserved.
  6. ;;;
  7. ;;; Use and copying of this software and preparation of derivative works
  8. ;;; based upon this software are permitted.  Any distribution of this
  9. ;;; software or derivative works must comply with all applicable United
  10. ;;; States export control laws.
  11. ;;; 
  12. ;;; This software is made available AS IS, and Xerox Corporation makes no
  13. ;;; warranty about the software, its performance or its conformity to any
  14. ;;; specification.
  15. ;;; 
  16. ;;; Any person obtaining a copy of this software is requested to send their
  17. ;;; name and post office or electronic mail address to:
  18. ;;;   CommonLoops Coordinator
  19. ;;;   Xerox PARC
  20. ;;;   3333 Coyote Hill Rd.
  21. ;;;   Palo Alto, CA 94304
  22. ;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)
  23. ;;;
  24. ;;; Suggestions, comments and requests for improvements are also welcome.
  25. ;;; *************************************************************************
  26. ;;;
  27. ;;; Permutation vectors.
  28. ;;;
  29.  
  30. (in-package 'pcl)
  31.  
  32. (defmacro instance-slot-index-from-slots-layout (slots-layout slot-name)
  33.   `(locally (declare #.*optimize-speed*)
  34.      (let ((slots-left ,slots-layout))
  35.        (if slots-left
  36.            (block nil
  37.              (let ((index 0))
  38.                (declare (type index index))
  39.                (tagbody
  40.                  begin-loop
  41.                   (if (eq (car slots-left) ,slot-name)
  42.                       (go return-index))
  43.                   (setf index (the index (1+ index)))
  44.                   (if (null (setf slots-left (cdr slots-left)))
  45.                       (return NIL))
  46.                   (go begin-loop)
  47.                  return-index)
  48.                index))))))
  49.  
  50. (defmacro instance-slot-index (wrapper slot-name)
  51.   `(instance-slot-index-from-slots-layout
  52.       (wrapper-instance-slots-layout ,wrapper) ,slot-name))
  53.  
  54.  
  55.  
  56. ;;;
  57. ;;;
  58. ;;;
  59. (defun optimize-slot-value-by-class-p (class slot-name type)
  60.   (let ((slotd (find-slot-definition class slot-name)))
  61.     (and slotd 
  62.      (or (not (eq *boot-state* 'complete))
  63.          (slot-accessor-std-p slotd type)))))
  64.  
  65. (defun optimize-generic-function-call (form required-parameters env)
  66.   (declare (ignore env required-parameters))
  67.   form
  68.   #||
  69.   (let* ((gf-name (car form))
  70.      (gf (gdefinition gf-name))
  71.      (arg-info (gf-arg-info gf))
  72.      (metatypes (arg-info-metatypes arg-info))
  73.      (nreq (length metatypes))
  74.      (applyp (arg-info-applyp arg-info)))
  75.     (declare (type index nreq))
  76.     (declare (ignore applyp))
  77.     (if (or (zerop nreq)
  78.         (not (<= nreq (length (cdr form))))
  79.         (not (every #'(lambda (arg mt)
  80.                 (declare (ignore mt))
  81.                 (when (consp arg)
  82.                               (setq arg (un-the arg)))
  83.                 (and (symbolp arg)
  84.                  (memq arg required-parameters))
  85.                 (let ((class-name (caddr (variable-declaration 
  86.                               'class arg env))))
  87.                   (and class-name (not (eq 't class-name)))))
  88.             (cdr form) metatypes)))
  89.     form
  90.     form))||#) ;`(maybe-fast-gf-call ,(car form) ,(cdr form))
  91.  
  92.  
  93. ;; For calls to a gf:
  94. ; gf-call-info: (gf call-info-vector . gf-function-vector)
  95. ; call-info-vector:     #(call-info1 ... call-infon)
  96. ; gf-function-vector:   #(function1 ... functionn)
  97. ; --> once an entry is made in call-info-vector, it is never moved or removed
  98. ; call-info:            (gf . arg-types)
  99. ; arg-type:             a type. `(arg ,n) is not allowed here.
  100.  
  101. ;; For calls from a method:
  102. ; method-gf-call-info:  (method-specializers method-call-info-vector . ???)
  103. ; arg-type:             a type or `(arg ,n)
  104. ; when arg-type is (arg n) the real type is either:
  105. ;   the arg's specializer or
  106. ;   (wrapper-eq ,wrapper) for a call appearing within a caching dfun gf
  107.  
  108. ; every optimized gf in a method has an entry in the method's method-call-info-vector
  109. ; a macro: (get-call-cell mciv-index .all-wrappers.) ->
  110. ;          index into the gf-function-vector
  111.  
  112. ;(defmacro maybe-fast-gf-call (gf-name args)
  113. ;   nil)
  114.  
  115.  
  116. (defun can-optimize-access (form required-parameters env)
  117.   (let ((type (ecase (car form)
  118.         (slot-value 'reader)
  119.         (set-slot-value 'writer)
  120.         (slot-boundp 'boundp)))
  121.     (var (un-the (cadr form)))
  122.     (slot-name (eval (caddr form)))) ; known to be constant
  123.     (when (symbolp var)
  124.       (let* ((rebound? (caddr (variable-declaration 'variable-rebinding var env)))
  125.          (parameter-or-nil (car (memq (or rebound? var) required-parameters))))
  126.     (when parameter-or-nil
  127.       (let* ((class-name (caddr (variable-declaration 
  128.                      'class parameter-or-nil env)))
  129.          (class (find-class class-name nil)))
  130.         (when (if (and class
  131.                (class-on-class-precedence-list-p
  132.                              *the-class-structure-object* class))
  133.               (optimize-slot-value-by-class-p class slot-name type)
  134.               (and class-name (not (eq class-name 't))))
  135.           (cons parameter-or-nil (or class class-name)))))))))
  136.  
  137. (defun optimize-slot-value (generic-function method slots sparameter form)
  138.   (if sparameter
  139.       (destructuring-bind (ignore ignore slot-name-form) form
  140.     (let ((slot-name (eval slot-name-form))
  141.               (class (if (consp sparameter) (cdr sparameter) *the-class-t*))
  142.           (parameter (if (consp sparameter) (car sparameter) sparameter)))
  143.           (if (eq *boot-state* 'complete)
  144.           (optimize-instance-access generic-function method class parameter
  145.                                         slots :read slot-name nil)
  146.               (optimize-std-instance-access class parameter
  147.                                             slots :read slot-name nil))))
  148.       `(fast-slot-value ,@(cdr form))))
  149.  
  150. (defun optimize-set-slot-value (generic-function method slots sparameter form)
  151.   (if sparameter
  152.       (destructuring-bind (ignore ignore slot-name-form new-value) form
  153.     (let ((slot-name (eval slot-name-form))
  154.               (class (if (consp sparameter) (cdr sparameter) *the-class-t*))
  155.           (parameter (if (consp sparameter) (car sparameter) sparameter)))
  156.           (if (eq *boot-state* 'complete)
  157.           (optimize-instance-access generic-function method class parameter
  158.                                     slots :write slot-name new-value)
  159.           (optimize-std-instance-access class parameter
  160.                                         slots :write slot-name new-value))))
  161.       `(fast-set-slot-value ,@(cdr form))))
  162.  
  163. (defun optimize-slot-boundp (generic-function method slots sparameter form)
  164.   (if sparameter
  165.       (destructuring-bind (ignore ignore slot-name-form new-value) form
  166.     (let ((slot-name (eval slot-name-form))
  167.               (class (if (consp sparameter) (cdr sparameter) *the-class-t*))
  168.           (parameter (if (consp sparameter) (car sparameter) sparameter)))
  169.           (if (eq *boot-state* 'complete)
  170.           (optimize-instance-access generic-function method class parameter
  171.                                     slots :boundp slot-name new-value)
  172.           (optimize-std-instance-access class parameter
  173.                                         slots :boundp slot-name new-value))))
  174.       `(fast-slot-boundp ,@(cdr form))))
  175.  
  176. ;;;
  177. ;;; The <slots> argument is an alist, the CAR of each entry is the name of
  178. ;;; a required parameter to the function.  The alist is in order, so the
  179. ;;; position of an entry in the alist corresponds to the argument's position
  180. ;;; in the lambda list.
  181. ;;; 
  182.  
  183. (defun optimize-std-instance-access (class parameter slots read/write
  184.                                      slot-name new-value)
  185.   (let* ((parameter-entry (assq parameter slots))
  186.          (class-name      (if (symbolp class) class (class-name class)))
  187.          (slot-entry      (assq slot-name (cdr parameter-entry)))
  188.          (index-name
  189.            (or (second slot-entry)
  190.                (intern
  191.                 (string-append "." (symbol-name parameter) "-"
  192.                                (symbol-name slot-name) "-INDEX.")))))
  193.     (unless parameter-entry
  194.       (error "Internal error in slot optimization."))
  195.     (unless (or slot-entry
  196.                 (skip-fast-slo